perm filename RVRS.F4[RST,LCS] blob
sn#200592 filedate 1976-02-11 generic text, type T, neo UTF8
00100 SUBROUTINE RVRS(IT)
00200 COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
00300 K=1
00400
00500 1 J=KPN(K)
00600 R=Q(J+1)
00700 IF(R.NE.1)GO TO 2
00800 C JUMP IF NOT A NOTE
00900 IF(Q(J+5).LT.10)GO TO 10
01000 C JUMP IF NO STEM ON IT
01100 KK=K+1
01200 3 IF(KK.GT.IT)RETURN
01300 JJ=KPN(KK)
01400 RR=Q(JJ+1)
01500 IF(RR.NE.1)GO TO 5
01600 C JUMP IF NOT A NOTE
01700 IF(Q(JJ+5).GE.10)GO TO 6
01800 C SKIP CHORD NOTES (NO STEM)
01900 7 KK=KK+1
02000 GO TO 3
02100 C DID NOT FIND BEAM NEARBY
02200 6 RZ=AMOD(Q(J+4),100.0)
02300 N=J+5
02400 A=10
02500 IF(RZ.GE.7)GO TO 60
02600 IF(Q(N).LT.20)GO TO 10
02700 C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
02800 A=-A
02900 GO TO 15
03000 60 IF(Q(N).GE.20)GO TO 10
03100 C THERE MUST BE A BETTER WAY!
03200 15 Q(N)=Q(N)+A
03300 GO TO 10
03400 8 IF(Q(N).LT.20)GO TO 10
03500 A=-A
03600 C STEM UP
03700 GO TO 15
03800 5 IF(RR.NE.6)GO TO 6
03900 20 B=Q(JJ+4)
04000 C=Q(JJ+5)
04100 D=(B+C)/2.
04200 IF(RR.EQ.5)GO TO 9
04300 IF(RR.NE.6)GO TO 10
04400 B=Q(JJ+6)+1.
04500 C SAVES RANGE OF BEAM +1.
04600 IF(Q(JJ+7).GE.20)GO TO 11
04700 C NOW STEMS ARE UP
04800 IF(D.LT.7)GO TO 12
04900 C JUMP TO 12 IF ALL OK
05000 CC C=-10
05100 JSTM=0
05200 C SAVE FOR REVERSED STEMS
05300 GO TO 23
05400 11 IF(D.GE.7.)GO TO 12
05500 C STEMS DOWN
05600 C JUMP IF NO REVERSE NEEDED
05700 JSTM=-1
05800 23 JH=0
05810 CHNG=0
05900 DO 16 N=K,IT
06000 KK=KPN(N)
06100 IF(Q(KK+3).GT.B)GO TO 140
06200 R=Q(KK+1)
06300 IF(R.NE.1)GO TO 17
06400 L=5
06500 R=Q(KK+8)
06600 C THE STEM LENGTH
06700 IF(R.EQ.999)R=0
06800 Q(KK+8)=-R
06900 C FOR THE INVERSION
07000 19 C=10.
07100 A=Q(KK+L)
07200 IF(A.GE.20)C=-C
07300 Q(KK+L)=C+A
07400 IF(JH.NE.0)GO TO 161
07500 C NEXT FOR 1ST NOTE UNDER BEAM
07600 JH=4
07700 160 R=Q(JJ+JH)-Q(KK+4)
07800 C=-1
07900 IF(JSTM)GO TO 163
07920 C=R
07940 R=1
08000 C NOW STEMS UP
08100 163 IF(R.GT.C)GO TO 162
08200 C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
08300 CHNG=C-R
08320 IF(JSTM.EQ.0)CHNG=-CHNG
08400 JH=JJ+4
08500 Q(JH)=Q(JH)+CHNG
08600 JH=JH+1
08700 Q(JH)=Q(JH)+CHNG
08800 162 IF(L)GO TO 141
08900 C FOR ESCAPE FROM LOOP
09000 161 JH=KK
09100 C JH SAVES PTR TO LAST NOTE UNDER BEAM
09200 GO TO 16
09300 17 IF(R.NE.6)GO TO 18
09400 C NOW IT'S A BEAM
09500 L=7
09600 GO TO 19
09700 18 IF(R.NE.5)GO TO 16
09800 C NOW IT'S A SLUR
09900 C=-3.8
10000 IF(Q(KK+7))C=-C
10100 CALL SLRV(KK,C)
10200 C TO REVERSE SLUR
10300 CC Q(KK+7)=-Q(KK+7)
10400 16 CONTINUE
10500 C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
10600 140 KK=JH
10700 L=-1
10800 JH=5
10900 C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
11000 GO TO 160
11100
11105 141 IF(CHNG.EQ.0)GO TO 14
11107 IF(CHNG)CHNG=-CHNG
11110 DO 142 N=K,IT
11120 C TO READJUST STEMS UNDER REVERSED BEAMS
11130 KK=KPN(N)
11137 IF(Q(KK+3).GT.B)GO TO 14
11144 IF(Q(KK+1).NE.1)GO TO 142
11165 Q(KK+8)=Q(KK+8)+CHNG
11172 C THE STEM LENGTH
11179 142 CONTINUE
11186 GO TO 14
11200
11300 C NEXT FOR SLURS
11400 9 B=-3.8
11500 IF(Q(JJ+7))GO TO 24
11600 IF(D.GT.7)GO TO 10
11700 C JUMP TO LEAVE STEM UP
11800 GO TO 25
11900 24 IF(D.LT.5)GO TO 10
12000 C JUMP TO LEAVE STEM DOWN
12100 B=-B
12200 CC25 Q(JJ+4)=Q(JJ+4)+B
12300 CC Q(JJ+5)=Q(JJ+5)+B
12400 CC Q(JJ+7)=-R
12500 25 CALL SLRV(JJ,B)
12600 GO TO 10
12700 12 DO 13 N=K+1,IT
12800 KK=KPN(N)
12900 13 IF(Q(KK+3).GT.B)GO TO 14
13000 C JUMP OUT WHEN PAST END OF BEAM.
13100 14 K=N-1
13200 GO TO 10
13300
13400 2 IF(R.NE.6)GO TO 21
13500 22 JJ=J
13600 RR=R
13700 GO TO 20
13800 21 IF(R.EQ.5)GO TO 22
13900 10 IF(K.GT.IT)RETURN
14000 K=K+1
14100 GO TO 1
14200 END